perm filename RVRS.F4[MSS,LCS] blob sn#260745 filedate 1977-01-28 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		SUBROUTINE RVRS(IT)
C00007 ENDMK
CāŠ—;
	SUBROUTINE RVRS(IT)
	COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
	K=1

1	R=CODEN(KPN,K,Q,J)
	IF(R.NE.1)GO TO 2
C  JUMP IF NOT A NOTE
	IF(Q(J+5).LT.10)GO TO 10
C  JUMP IF NO STEM ON IT
	KK=K+1
3	IF(KK.GT.IT)RETURN
	RR=CODEN(KPN,KK,Q,JJ)
	IF(RR.NE.1)GO TO 5
C  JUMP IF NOT A NOTE
	IF(Q(JJ+5).GE.10)GO TO 6
C SKIP CHORD NOTES (NO STEM)
7	KK=KK+1
	GO TO 3
C DID NOT FIND BEAM NEARBY
6	RZ=AMOD(Q(J+4),100.0)
	N=J+5
	A=10
	IF(RZ.GE.7)GO TO 60
	IF(Q(N).LT.20)GO TO 10
C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
	A=-A
	GO TO 15
60	IF(Q(N).GE.20)GO TO 10
C  THERE MUST BE A BETTER WAY!
15	Q(N)=Q(N)+A
	GO TO 10
CCCCC8	IF(Q(N).LT.20)GO TO 10
CCCCC	A=-A
C  STEM UP
CCCCC	GO TO 15
5	IF(RR.NE.6)GO TO 6
20	B=Q(JJ+4)
	C=Q(JJ+5)
	D=(B+C)/2.
	IF(RR.EQ.5)GO TO 9
	IF(RR.NE.6)GO TO 10
	B=Q(JJ+6)+1.
C  SAVES RANGE OF BEAM +1.
	IF(Q(JJ+7).GE.20)GO TO 11
C  NOW STEMS ARE UP
	IF(D.LT.7)GO TO 12
C JUMP TO 12 IF ALL OK
CC	C=-10
	JSTM=0 
C SAVE FOR REVERSED STEMS
	GO TO 23
11	IF(D.GE.7.)GO TO 12
C  STEMS DOWN
C JUMP IF NO REVERSE NEEDED
	JSTM=-1
23	JH=0
	CHNG=0
	DO 16 N=K,IT
	R=CODEN(KPN,N,Q,KK)
	IF(Q(KK+3).GT.B)GO TO 140
	IF(R.NE.1)GO TO 17
	L=5+KK
	IF(Q(L).LT.10)GO TO 16
C  PASS NOTES WITH NO STEM
	R=Q(KK+8)
C  THE STEM LENGTH
	IF(R.EQ.999)R=0
	Q(KK+8)=-R
C  FOR THE INVERSION
19	C=10.
	A=Q(L)
	IF(A.GE.20)C=-C
	Q(L)=C+A
	IF(JH.NE.0)GO TO 161
C NEXT FOR 1ST NOTE UNDER BEAM
	JH=4
160	R=Q(JJ+JH)-Q(KK+4)
	C=-1 
	IF(JSTM)GO TO 163
	C=R
	R=1
C NOW STEMS UP
163	IF(R.GT.C)GO TO 162
C JUMP IF BEAM IS NOT TOO CLOSE TO NOTE
	CHNG=C-R
	IF(JSTM.EQ.0)CHNG=-CHNG
	JH=JJ+4
	Q(JH)=Q(JH)+CHNG
	JH=JH+1
	Q(JH)=Q(JH)+CHNG
162	IF(L)GO TO 141
C  FOR ESCAPE FROM LOOP
161	JH=KK
C  JH SAVES PTR TO LAST NOTE UNDER BEAM
	GO TO 16
17	IF(R.NE.6)GO TO 18
C NOW IT'S A BEAM
	L=7+KK
	GO TO 19
18	IF(R.NE.5)GO TO 16
C NOW IT'S A SLUR
	C=-3.8
	IF(Q(KK+7))C=-C
	CALL SLRV(KK,C)
C  TO REVERSE SLUR
CC	Q(KK+7)=-Q(KK+7)
16	CONTINUE
C  SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
140	KK=JH
	L=-1
	JH=5
C GO BACK TO CHECK HGT OF LAST NOTE AND RIGHT END OF BEAM
	GO TO 160

141	IF(CHNG.EQ.0)GO TO 14
	IF(CHNG)CHNG=-CHNG
	DO 142 N=K,IT
C  TO READJUST STEMS UNDER REVERSED BEAMS
	KK=KPN(N)
	IF(Q(KK+3).GT.B)GO TO 14
	IF(Q(KK+1).NE.1)GO TO 142
	Q(KK+8)=Q(KK+8)+CHNG
C  THE STEM LENGTH
142	CONTINUE
	GO TO 14

C NEXT FOR SLURS
9	B=-3.8
	IF(Q(JJ+7))GO TO 24
	IF(D.GT.7)GO TO 10
C JUMP TO LEAVE STEM UP
	GO TO 25
24	IF(D.LT.5)GO TO 10
C JUMP TO LEAVE STEM DOWN
	B=-B
CC25	Q(JJ+4)=Q(JJ+4)+B
CC	Q(JJ+5)=Q(JJ+5)+B
CC	Q(JJ+7)=-R
25	CALL SLRV(JJ,B)
	GO TO 10
12	DO 13 N=K+1,IT
	KK=KPN(N)
13	IF(Q(KK+3).GT.B)GO TO 14
C  JUMP OUT WHEN PAST END OF BEAM.
14	K=N-1
	GO TO 10

2	IF(R.NE.6)GO TO 21
22	JJ=J
	RR=R
	GO TO 20
21	IF(R.EQ.5)GO TO 22
10	IF(K.GT.IT)RETURN
	K=K+1
	GO TO 1
	END